home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _8aee61d2af98281ff65be98ad62b224b < prev    next >
Encoding:
Text File  |  2002-05-30  |  10.6 KB  |  541 lines
  1. # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Table;
  5. use strict;
  6.  
  7. use vars qw($VERSION);
  8. $VERSION = '3.020'; # $Id: //depot/Tk8/Tk/Table.pm#20 $
  9.  
  10. use Tk::Pretty;
  11. use AutoLoader;
  12. use base qw(Tk::Frame);
  13.  
  14. Construct Tk::Widget 'Table';
  15.  
  16. sub ClassInit
  17. {
  18.  my ($class,$mw) = @_;
  19.  $mw->bind($class,'<Configure>',['QueueLayout',8]);
  20.  $mw->bind($class,'<FocusIn>',  'NoOp');
  21.  $mw->XYscrollBind($class);
  22.  return $class;
  23. }
  24.  
  25. sub _view
  26. {
  27.  my ($t,$s,$page,$a,$op,$num,$type) = @_;
  28.  if ($op eq 'moveto')
  29.   {
  30.    $$s = int(@$a*$num);
  31.   }
  32.  else
  33.   {
  34.    $num *= ($page/2) if ($type eq 'pages');
  35.    $$s += $num;
  36.   }
  37.  $$s = 0 if ($$s < 0);
  38.  $t->QueueLayout(4);
  39. }
  40.  
  41. sub xview
  42. {
  43.  my $t  = shift;
  44.  $t->_view(\$t->{Left},$t->cget('-columns'),$t->{Width},@_);
  45. }
  46.  
  47. sub yview
  48. {
  49.  my $t  = shift;
  50.  $t->_view(\$t->{Top},$t->cget('-rows'),$t->{Height},@_);
  51. }
  52.  
  53. sub FocusChildren
  54. {
  55.  my $t = shift;
  56.  return () if ($t->cget('-takefocus'));
  57.  return $t->SUPER::FocusChildren;
  58. }
  59.  
  60. sub Populate
  61. {
  62.  my ($t,$args) = @_;
  63.  $t->SUPER::Populate($args);
  64.  $t->ConfigSpecs('-scrollbars'         => [METHOD   => 'scrollbars','Scrollbars','nw'],
  65.                  '-takefocus'          => [SELF => 'takeFocus','TakeFocus',1],
  66.                  '-rows'               => [METHOD => 'rows','Rows',10],
  67.                  '-fixedrows'          => [METHOD => 'fixedRows','FixedRows',0],
  68.                  '-columns'            => [METHOD => 'columns','Columns',10],
  69.                  '-fixedcolumns'       => [METHOD => 'fixedColumn','FixedColumns',0],
  70.                  '-highlightthickness' => [SELF => 'highlightThickness','HighlightThickness',2]
  71.                  );
  72.  $t->{'Width'}  = [];
  73.  $t->{'Height'} = [];
  74.  $t->{'Row'}    = [];
  75.  $t->{'Slave'}  = {};
  76.  $t->{'Top'}    = 0;
  77.  $t->{'Left'}   = 0;
  78.  $t->{'Bottom'} = 0;
  79.  $t->{'Right'}  = 0;
  80.  $t->{LayoutPending} = 0;
  81. }
  82.  
  83. sub sizeN
  84. {
  85.  my ($n,$a) = @_;
  86.  my $max = 0;
  87.  my $i = 0;
  88.  my $sum = 0;
  89.  while ($i < @$a && $i < $n)
  90.   {
  91.    my $n = $a->[$i++];
  92.    $a->[$i-1] = $n = 0 unless (defined $n);
  93.    $sum += $n;
  94.   }
  95.  $max = $sum if ($sum > $max);
  96.  while ($i < @$a)
  97.   {
  98.    $sum = $sum-$a->[$i-$n]+$a->[$i];
  99.    $max = $sum if ($sum > $max);
  100.    $i++;
  101.   }
  102.  return $max;
  103. }
  104.  
  105. sub total
  106. {
  107.  my ($a)   = @_;
  108.  my $total = 0;
  109.  my $x;
  110.  foreach $x (@{$a})
  111.   {
  112.    $total += $x;
  113.   }
  114.  return $total;
  115. }
  116.  
  117. sub constrain
  118. {
  119.  my ($sb,$a,$pixels,$fixed) = @_;
  120.  my $n     = $$sb+$fixed;
  121.  my $total = 0;
  122.  my $i;
  123.  $n = @$a if ($n > @$a);
  124.  $n = $fixed if ($n < $fixed);
  125.  for ($i= 0; $i < $fixed; $i++)
  126.   {
  127.     (defined($a->[$i])) && ($total += $a->[$i]);
  128.   }
  129.  for ($i=$n; $total < $pixels && $i < @$a; $i++)
  130.   {
  131.    $total += $a->[$i];
  132.   }
  133.  while ($n > $fixed)
  134.   {
  135.    if (($total += $a->[--$n]) > $pixels)
  136.     {
  137.      $n++;
  138.      last;
  139.     }
  140.   }
  141.  $$sb = $n-$fixed;
  142. }
  143.  
  144. sub Layout
  145. {
  146.  my ($t)    = @_;
  147.  return unless Tk::Exists($t);
  148.  my $rows   = @{$t->{Row}};
  149.  my $bw     = $t->cget(-highlightthickness);
  150.  my $frows  = $t->cget(-fixedrows);
  151.  my $fcols  = $t->cget(-fixedcolumns);
  152.  my $sb     = $t->cget(-scrollbars);
  153.  my $H      = $t->Height;
  154.  my $W      = $t->Width;
  155.  my $tadj   = $bw;
  156.  my $badj   = $bw;
  157.  my $ladj   = $bw;
  158.  my $radj   = $bw;
  159.  my @xs     = ($W,0,0,0);
  160.  my @ys     = (0,$H,0,0);
  161.  my $xsb;
  162.  my $ysb;
  163.  
  164.  my $why   = $t->{LayoutPending};
  165.  $t->{LayoutPending} = 0;
  166.  
  167.  if ($sb =~ /^[ns]/)
  168.   {
  169.    $t->{xsb} = $t->Scrollbar(-orient => 'horizontal', -command => ['xview' => $t]) unless (defined $t->{xsb});
  170.    $xsb   = $t->{xsb};
  171.    $xs[3] = $xsb->ReqHeight;
  172.    if ($sb =~ /^n/)
  173.     {
  174.      $xs[1] = $tadj;
  175.      $tadj += $xs[3];
  176.     }
  177.    else
  178.     {
  179.      $badj += $xs[3];
  180.      $xs[1] = $H-$badj;
  181.     }
  182.   }
  183.  else
  184.   {
  185.    $t->{xsb}->UnmapWindow if (defined $t->{xsb});
  186.   }
  187.  
  188.  if ($sb =~ /[ew]$/)
  189.   {
  190.    $t->{ysb} = $t->Scrollbar(-orient => 'vertical', -command => ['yview' => $t]) unless (defined $t->{ysb});
  191.    $ysb    = $t->{ysb};
  192.    $ys[2]  = $ysb->ReqWidth;
  193.    if ($sb =~ /w$/)
  194.     {
  195.      $ys[0] = $ladj;
  196.      $ladj += $ys[2];
  197.     }
  198.    else
  199.     {
  200.      $radj += $ys[2];
  201.      $ys[0] = $W-$radj;
  202.     }
  203.   }
  204.  else
  205.   {
  206.    $t->{ysb}->UnmapWindow if (defined $t->{ysb});
  207.   }
  208.  
  209.  constrain(\$t->{Top}, $t->{Height},$H-($tadj+$badj),$frows);
  210.  constrain(\$t->{Left},$t->{Width}, $W-($ladj+$radj),$fcols);
  211.  
  212.  my $top  = $t->{Top}+$frows;
  213.  my $left = $t->{Left}+$fcols;
  214.  
  215.  if ($why & 49)
  216.   {
  217.    # Width and/or Height of element or
  218.    # number of rows and/or columns or
  219.    # scrollbar presence has changed
  220.    my $w = sizeN($t->cget('-columns'),$t->{Width})+$radj+$ladj;
  221.    my $h = sizeN($t->cget('-rows'),$t->{Height})+$tadj+$badj;
  222.    $t->GeometryRequest($w,$h);
  223.   }
  224.  
  225.  if ($rows)
  226.   {
  227.    my $cols  = @{$t->{Width}};
  228.    my $yhwm  = $top-$frows;
  229.    my $xhwm  = $left-$fcols;
  230.    my $y     = $tadj;
  231.    my $r;
  232.    for ($r = 0; $r < $rows; $r++)
  233.     {
  234.      my $h = $t->{Height}[$r];
  235.      if (($r < $top && $r >= $frows) || ($y+$h > $H-$badj))
  236.       {
  237.        if (defined $t->{Row}[$r])
  238.         {
  239.          my $c;
  240.          for ($c = 0; $c < @{$t->{Row}[$r]}; $c++)
  241.           {
  242.            my $s = $t->{Row}[$r][$c];
  243.            if (defined $s)
  244.             {
  245.              $s->UnmapWindow;
  246.              if ($why & 1)
  247.               {
  248.                my $w = $t->{Width}[$c];
  249.                $s->ResizeWindow($w,$h);
  250.               }
  251.             }
  252.           }
  253.         }
  254.       }
  255.      else
  256.       {
  257.        my $hwm  = $left-$fcols;
  258.        my $sh   = 0;
  259.        my $x    = $ladj;
  260.        my $c;
  261.        $ys[1] = $y if ($y < $ys[1] && $r >= $frows);
  262.        for ($c = 0; $c <$cols; $c++)
  263.         {
  264.          my $s = $t->{Row}[$r][$c];
  265.          my $w = $t->{Width}[$c];
  266.          if (($c < $left && $c >= $fcols) || ($x+$w > $W-$radj) )
  267.           {
  268.            if (defined $s)
  269.             {
  270.              $s->UnmapWindow;
  271.              $s->ResizeWindow($w,$h) if ($why & 1);
  272.             }
  273.           }
  274.          else
  275.           {
  276.            $xs[0] = $x if ($x < $xs[0] && $c >= $fcols);
  277.            if (defined $s)
  278.             {
  279.              if ($why & 1)
  280.               {
  281.                $s->MoveResizeWindow($x,$y,$w,$h);
  282.               }
  283.              else
  284.               {
  285.                $s->MoveWindow($x,$y);
  286.               }
  287.              $s->MapWindow;
  288.             }
  289.            $x     += $w;
  290.            if ($c >= $fcols)
  291.             {
  292.              $hwm++;
  293.              $sh    += $w
  294.             }
  295.           }
  296.         }
  297.        $xhwm = $hwm if ($hwm > $xhwm);
  298.        $xs[2] = $sh if ($sh > $xs[2]);
  299.        $y     += $h;
  300.        if ($r >= $frows)
  301.         {
  302.          $ys[3] += $h;
  303.          $yhwm++;
  304.         }
  305.       }
  306.     }
  307.    $t->{Bottom} = $yhwm;
  308.    $t->{Right}  = $xhwm;
  309.    if (defined $xsb && $xs[2] > 0)
  310.     {
  311.      $xsb->MoveResizeWindow(@xs);
  312.      $cols -= $fcols;
  313.      if ($cols > 0)
  314.       {
  315.        $xsb->set($t->{Left}/$cols,$t->{Right}/$cols);
  316.        $xsb->MapWindow;
  317.       }
  318.     }
  319.    if (defined $ysb && $ys[3] > 0)
  320.     {
  321.      $ysb->MoveResizeWindow(@ys);
  322.      $rows -= $frows;
  323.      if ($rows > 0)
  324.       {
  325.        $ysb->set($t->{Top}/$rows,$t->{Bottom}/$rows);
  326.        $ysb->MapWindow;
  327.       }
  328.     }
  329.   }
  330. }
  331.  
  332. sub QueueLayout
  333. {
  334.  my ($m,$why) = @_;
  335.  $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending});
  336.  $m->{LayoutPending} |= $why;
  337. }
  338.  
  339. sub SlaveGeometryRequest
  340. {
  341.  my ($m,$s) = @_;
  342.  my ($row,$col) = @{$m->{Slave}{$s->PathName}};
  343.  my $sw = $s->ReqWidth;
  344.  my $sh = $s->ReqHeight;
  345.  my $sz = 0;
  346.  if ($sw > $m->{Width}[$col])
  347.   {
  348.    $m->{Width}[$col] = $sw;
  349.    $m->QueueLayout(1);
  350.    $sz++;
  351.   }
  352.  if ($sh > $m->{Height}[$row])
  353.   {
  354.    $m->{Height}[$row] = $sh;
  355.    $m->QueueLayout(1);
  356.    $sz++;
  357.   }
  358.  if (!$sz)
  359.   {
  360.    $s->ResizeWindow($m->{Width}[$col],$m->{Height}[$row]);
  361.   }
  362. }
  363.  
  364. sub get
  365. {
  366.  my ($t,$row,$col) = @_;
  367.  return $t->{Row}[$row][$col];
  368. }
  369.  
  370. sub LostSlave
  371. {
  372.  my ($t,$s) = @_;
  373.  my $info   = delete $t->{Slave}{$s->PathName};
  374.  if (defined $info)
  375.   {
  376.    my ($row,$col) = @$info;
  377.    $t->{Row}[$row][$col] = undef;
  378.    $s->UnmapWindow;
  379.   }
  380.  else
  381.   {
  382.    $t->BackTrace('Cannot find' . $s->PathName);
  383.   }
  384.  $t->QueueLayout(2);
  385. }
  386.  
  387. sub put
  388. {
  389.  my ($t,$row,$col,$w) = @_;
  390.  $w = $t->Label(-text => $w) unless (ref $w);
  391.  $t->ManageGeometry($w);
  392.  unless (defined $t->{Row}[$row])
  393.   {
  394.    $t->{Row}[$row] = [];
  395.    $t->{Height}[$row] = 0;
  396.   }
  397.  unless (defined $t->{Width}[$col])
  398.   {
  399.    $t->{Width}[$col] = 0;
  400.   }
  401.  my $old = $t->{Row}[$row][$col];
  402.  if (defined $old)
  403.   {
  404.    $old->UnmanageGeometry;
  405.    $t->LostSlave($old);
  406.   }
  407.  $t->{Row}[$row][$col] = $w;
  408.  $t->{Slave}{$w->PathName} = [$row,$col];
  409.  $t->SlaveGeometryRequest($w);
  410.  $t->QueueLayout(2);
  411.  return $old;
  412. }
  413.  
  414. #
  415. # configure methods
  416. #
  417.  
  418. sub scrollbars
  419. {
  420.  my ($t,$v) = @_;
  421.  if (@_ > 1)
  422.   {
  423.    $t->_configure(-scrollbars => $v);
  424.    $t->QueueLayout(32);
  425.   }
  426.  return $t->_cget('-scrollbars');
  427. }
  428.  
  429. sub rows
  430. {
  431.  my ($t,$r) = @_;
  432.  if (@_ > 1)
  433.   {
  434.    $t->_configure(-rows => $r);
  435.    $t->QueueLayout(16);
  436.   }
  437.  return $t->_cget('-rows');
  438. }
  439.  
  440. sub fixedrows
  441. {
  442.  my ($t,$r) = @_;
  443.  if (@_ > 1)
  444.   {
  445.    $t->_configure(-fixedrows => $r);
  446.    $t->QueueLayout(16);
  447.   }
  448.  return $t->_cget('-fixedrows');
  449. }
  450.  
  451. sub columns
  452. {
  453.  my ($t,$r) = @_;
  454.  if (@_ > 1)
  455.   {
  456.    $t->_configure(-columns => $r);
  457.    $t->QueueLayout(16);
  458.   }
  459.  return $t->_cget('-columns');
  460. }
  461.  
  462. sub fixedcolumns
  463. {
  464.  my ($t,$r) = @_;
  465.  if (@_ > 1)
  466.   {
  467.    $t->_configure(-fixedcolumns => $r);
  468.    $t->QueueLayout(16);
  469.   }
  470.  return $t->_cget('-fixedcolumns');
  471. }
  472.  
  473. 1;
  474. __END__
  475. sub Create
  476. {
  477.  my $t = shift;
  478.  my $r = shift;
  479.  my $c = shift;
  480.  my $kind = shift;
  481.  $t->put($r,$c,$t->$kind(@_));
  482. }
  483.  
  484. sub totalColumns
  485. {
  486.  scalar @{shift->{'Width'}};
  487. }
  488.  
  489. sub totalRows
  490. {
  491.  scalar @{shift->{'Height'}};
  492. }
  493.  
  494. sub Posn
  495. {
  496.  my ($t,$s) = @_;
  497.  my $info   = $t->{Slave}{$s->PathName};
  498.  return (wantarray) ? @$info : $info;
  499. }
  500.  
  501. sub see
  502. {
  503.  my $t = shift;
  504.  my ($row,$col) = (@_ == 2) ? @_ : @{$t->{Slave}{$_[0]->PathName}};
  505.  my $see = 1;
  506.  if (($row -= $t->cget('-fixedrows')) >= 0)
  507.   {
  508.    if ($row < $t->{Top})
  509.     {
  510.      $t->{Top} = $row;
  511.      $t->QueueLayout(4);
  512.      $see = 0;
  513.     }
  514.    elsif ($row >= $t->{Bottom})
  515.     {
  516.      $t->{Top} += ($row - $t->{Bottom}+1);
  517.      $t->QueueLayout(4);
  518.      $see = 0;
  519.     }
  520.   }
  521.  if (($col -= $t->cget('-fixedcolumns')) >= 0)
  522.   {
  523.    if ($col < $t->{Left})
  524.     {
  525.      $t->{Left} = $col;
  526.      $t->QueueLayout(4);
  527.      $see = 0;
  528.     }
  529.    elsif ($col >= $t->{Right})
  530.     {
  531.      $t->{Left} += ($col - $t->{Right}+1);
  532.      $t->QueueLayout(4);
  533.      $see = 0;
  534.     }
  535.   }
  536.  return $see;
  537. }
  538.  
  539. =cut
  540.  
  541.